home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / pctj8407.arc / MATRIX.PAS < prev    next >
Pascal/Delphi Source File  |  1986-09-14  |  2KB  |  114 lines
  1. PROGRAM MATRIX;
  2.  
  3. (* By Alan R. Miller *)
  4. (* from: PASCAL PROGRAMS FOR SCIENTISTS AND ENGINEERS *)
  5. (* (c) 1981 by Sybex, Inc. *)
  6.  
  7. CONST
  8.   RMAX = 20;
  9.   CMAX = 20;
  10.  
  11. TYPE
  12.   ARY    = ARRAY[1..RMAX] OF REAL;
  13.   ARYS    = ARRAY[1..CMAX] OF REAL;
  14.   ARY2    = ARRAY[1..RMAX, 1..CMAX] OF REAL;
  15.   ARY2S = ARRAY[1..RMAX, 1..CMAX] OF REAL;
  16.  
  17. VAR
  18.   Y    : ARY;
  19.   G    : ARYS;
  20.   X    : ARY2;
  21.   A    : ARY2S;
  22.   NROW,NCOL    : INTEGER;
  23.   CH    : CHAR;
  24.  
  25.  
  26. PROCEDURE GET_DATA(VAR X : ARY2;
  27.            VAR Y : ARY;
  28.            VAR NROW,NCOL : INTEGER);
  29.  
  30. (* Get values for NROW, NCOL, and arrays X, Y *)
  31.  
  32. VAR I,J : INTEGER;
  33.  
  34. BEGIN
  35.   NROW:=10;
  36.   NCOL:=10;
  37.   FOR I:=1 TO NROW DO
  38.     BEGIN
  39.       X[I,1]:=1;
  40.       FOR J:=2 TO NCOL DO
  41.         X[I,J]:=I*X[I,J-1];
  42.       Y[I]:=2*I
  43.     END
  44. END;    (* GET_DATA *)
  45.  
  46.  
  47. PROCEDURE WRITE_DATA;
  48.  
  49. (* Print out the answers *)
  50.  
  51. VAR I,J : INTEGER;
  52.  
  53. BEGIN
  54.   WRITELN;
  55.   WRITELN('       X                          Y');
  56.   FOR I:=1 TO NROW DO
  57.     BEGIN
  58.       FOR J:=1 TO NCOL DO
  59.     WRITE(X[I,J]:9:1,' ');
  60.       WRITELN(':',Y[I]:9:1)
  61.     END;
  62.   WRITELN;
  63.   WRITELN('       A                          G');
  64.   FOR I:=1 TO NCOL DO
  65.     BEGIN
  66.       FOR J:=1 TO NCOL DO
  67.       WRITE(A[I,J]:10:1,' ');
  68.       WRITELN(':',G[I]:10:1)
  69.     END
  70. END;  (* WRITE_DATA *)
  71.  
  72.  
  73. PROCEDURE SQUARE(X    : ARY2;
  74.          Y    : ARY;
  75.          VAR A    : ARY2S;
  76.          VAR G  : ARYS;
  77.          NROW,NCOL : INTEGER);
  78.  
  79. (* Matrix multiplication routine *)
  80. (* A = transpose X times X       *)
  81. (* G = Y times X         *)
  82.  
  83. VAR I,K,L : INTEGER;
  84.  
  85. BEGIN  (* SQUARE *)
  86.   FOR K:=1 TO NCOL DO
  87.     BEGIN
  88.       FOR L:=1 TO K DO
  89.     BEGIN
  90.       A[K,L]:=0;
  91.       FOR I:=1 TO NROW DO
  92.         BEGIN
  93.           A[K,L]:=A[K,L]+X[I,L]*X[I,K];
  94.           IF K<>L THEN A[L,K]:=A[K,L]
  95.         END
  96.     END;    (* L loop *)
  97.       G[K]:=0;
  98.       FOR I:=1 TO NROW DO
  99.         G[K]:=G[K]+Y[I]*X[I,K]
  100.     END         (* K loop *)
  101. END;  (* SQUARE *)
  102.  
  103.  
  104. BEGIN    (* MAIN *)
  105.   GET_DATA(X,Y,NROW,NCOL);
  106.   WRITE('>>Press (CR) to begin calculations: ');
  107.   READLN(CH);
  108.   WRITE('>>Starting matrix inversion..');
  109.   SQUARE(X,Y,A,G,NROW,NCOL);
  110.   WRITELN('..all done!');
  111.   WRITE_DATA
  112. END.
  113.  
  114.